home *** CD-ROM | disk | FTP | other *** search
/ Cream of the Crop 1 / Cream of the Crop 1.iso / EDUCATE / CATTEST.ARJ / UUESTUFF.PAS < prev    next >
Pascal/Delphi Source File  |  1991-03-29  |  15KB  |  562 lines
  1. unit uuestuff;
  2.  
  3. {$UNDEF debug}
  4. {v1.1 uuencode from Toad Hall Tweak, 9 May 90
  5.  - Converted reserved, other word case to my preferred style.
  6.  - Converted for Turbo Pascal v5.0 compilation ("Uses", etc.)
  7. }
  8.  
  9. interface
  10. uses CRT,DOS;
  11. procedure encode;
  12. procedure decode;
  13. procedure hide(question_name:string);
  14. implementation
  15.  
  16.  
  17.  
  18.  
  19. procedure  decode;
  20. {v1.1 Toad Hall Tweak, 9 May 90
  21.  - Reformatted in case, style, indentation, etc. to my preferences.
  22.  - Tweaked for Turbo Pascal v5.0
  23.  David Kirschbaum
  24.  Toad Hall
  25. }
  26. CONST
  27.   DefaultSuffix = '.uue';
  28.   OFFSET = 32;
  29. TYPE
  30.   Str80 = STRING[80];
  31. VAR
  32.   Infile: TEXT;
  33.   Fi    : FILE OF Byte;
  34.   Outfile: FILE OF Byte;
  35.   linenum: INTEGER;
  36.   Line: Str80;
  37.   size,remaining : longint;  {v1.1 REAL;}
  38. PROCEDURE Abort(Msg: Str80);
  39.   BEGIN
  40.     WRITELN;
  41.     IF linenum > 0 THEN WRITE('Aborting, line = ', linenum, ': ');
  42.     WRITELN(Msg);
  43.     HALT
  44.   END; {of Abort}
  45. PROCEDURE NextLine(VAR S: Str80);
  46.   BEGIN
  47.     Inc(linenum);
  48.     {write('.');}
  49.     READLN(Infile, S);
  50.     Dec(remaining,LENGTH(S)-2);  {-2 is for CR/LF}
  51.     (*WRITE('bytes remaining: ',remaining:7,' (',
  52.           remaining/size*100.0:3:0,'%)',CHR(13));*)
  53.   END; {of NextLine}
  54. PROCEDURE Init;
  55.   PROCEDURE GetInFile;
  56.     VAR Infilename: Str80;
  57.     BEGIN
  58.       Infilename := 'OLDGRADE.BK$';
  59.       ASSIGN(Infile, Infilename);
  60.       {$I-}
  61.       RESET(Infile);
  62.       {$i+}
  63.       IF IOResult > 0 THEN Abort (CONCAT('Can''t open ', Infilename));
  64.       ASSIGN(Fi,Infilename); RESET(Fi);
  65.       size := FileSize(Fi);
  66.       CLOSE(Fi);
  67. {      IF size < 0 THEN size:=size+65536.0; }
  68.       remaining := size;
  69.     END;  {of GetInFile}
  70.   PROCEDURE GetOutFile;
  71.     VAR
  72.       Header, Mode, Outfilename: Str80;
  73.       Ch: CHAR;
  74.     PROCEDURE ParseHeader;
  75.       VAR index: INTEGER;
  76.       PROCEDURE NextWord(VAR Word:Str80; VAR index: INTEGER);
  77.         BEGIN
  78.           Word := '';
  79.           WHILE Header[index] = ' ' DO BEGIN
  80.             Inc(index);
  81.             IF index > LENGTH(Header) THEN Abort ('Incomplete header')
  82.           END;
  83.           WHILE Header[index] <> ' ' DO BEGIN
  84.             Word := CONCAT(Word, Header[index]);
  85.             Inc(index);
  86.           END
  87.         END; {of NextWord}
  88.       BEGIN {ParseHeader}
  89.         Header := CONCAT(Header, ' ');
  90.         index := 7;
  91.         NextWord(Mode, index);
  92.         NextWord(Outfilename, index)
  93.       END; {of ParseHeader}
  94.     BEGIN {GetOutFile}
  95.       IF EOF(Infile) THEN Abort('Nothing to decode.');
  96.       NextLine (Header);
  97.       WHILE NOT ((COPY(Header, 1, 6) = 'begin ') OR EOF(Infile)) DO
  98.         NextLine(Header);
  99.       WRITELN;
  100.       IF EOF(Infile) THEN Abort('Nothing to decode.');
  101.       ParseHeader;
  102.  
  103.       OutFileName := 'NEWGRADE.BK$';
  104.  
  105.       ASSIGN(Outfile, Outfilename);
  106.       {$I-}
  107.       RESET(Outfile);
  108.       {$I+}
  109.       IF IOResult = 0 THEN BEGIN
  110.         WRITE ('Overwrite current ', Outfilename, '? [Y/N] ');
  111.         REPEAT
  112.           Ch := Upcase(ReadKey);  {v1.1}
  113.         UNTIL Ch IN ['Y', 'N'];
  114.         WRITELN(Ch);
  115.         IF Ch = 'N' THEN Abort ('Overwrite cancelled.')
  116.       END;
  117.       REWRITE (Outfile);
  118.     END; {of GetOutFile}
  119.   BEGIN {Init}
  120.     linenum := 0;
  121.     GetInFile;
  122.     GetOutFile;
  123.   END; { init}
  124. FUNCTION Check_Line: BOOLEAN;
  125.   BEGIN
  126.     IF Line = '' THEN Abort ('Blank line in file');
  127.     Check_Line := NOT (Line[1] IN [' ', '`'])
  128.   END; {of Check_Line}
  129. PROCEDURE DecodeLine;
  130.   VAR
  131.     lineIndex, byteNum, count, i: INTEGER;
  132.     chars: ARRAY [0..3] OF Byte;
  133.     hunk: ARRAY [0..2] OF Byte;
  134. {    procedure debug;
  135.       var i: integer;
  136.       procedure writebin(x: byte);
  137.         var i: integer;
  138.         begin
  139.           for i := 1 to 8 do begin
  140.               write ((x and $80) shr 7);
  141.               x := x shl 1
  142.             end;
  143.           write (' ')
  144.         end;
  145.       begin
  146.         writeln;
  147.         for i := 0 to 3 do writebin(chars[i]);
  148.         writeln;
  149.         for i := 0 to 2 do writebin(hunk[i]);
  150.         writeln
  151.       end;      }
  152.   FUNCTION Next_Ch: CHAR;
  153.     BEGIN
  154.       Inc(lineIndex);
  155.       IF lineIndex > LENGTH(Line) THEN Abort('Line too short.');
  156.       IF NOT (Line[lineindex] IN [' '..'`'])
  157.       THEN Abort('Illegal character in line.');
  158. {     write(line[lineindex]:2);}
  159.       IF Line[lineindex] = '`' THEN Next_Ch := ' '
  160.                                ELSE Next_Ch := Line[lineIndex]
  161.     END; {of Next_Ch}
  162.   PROCEDURE DecodeByte;
  163.     PROCEDURE GetNextHunk;
  164.       VAR i: INTEGER;
  165.       BEGIN
  166.         FOR i := 0 TO 3 DO chars[i] := ORD(Next_Ch) - OFFSET;
  167.         hunk[0] := (chars[0] ShL 2) + (chars[1] ShR 4);
  168.         hunk[1] := (chars[1] ShL 4) + (chars[2] ShR 2);
  169.         hunk[2] := (chars[2] ShL 6) + chars[3];
  170.         byteNum := 0  {;
  171.         debug          }
  172.       END; {of GetNextHunk}
  173.     BEGIN {DecodeByte}
  174.       IF byteNum = 3 THEN GetNextHunk;
  175.       WRITE (Outfile, hunk[byteNum]);
  176.       {writeln(bytenum, ' ', hunk[byteNum]);}
  177.       Inc(byteNum)
  178.     END; {of DecodeByte}
  179.   BEGIN {DecodeLine}
  180.     lineIndex := 0;
  181.     byteNum := 3;
  182.     count := (ORD(Next_Ch) - OFFSET);
  183.     FOR i := 1 TO count DO DecodeByte
  184.   END; {of DecodeLine}
  185. PROCEDURE Terminate;
  186.   VAR Trailer: Str80;
  187.   BEGIN
  188.     IF EOF(Infile) THEN Abort ('Abnormal end.');
  189.     NextLine (trailer);
  190.     IF LENGTH (trailer) < 3 THEN Abort ('Abnormal end.');
  191.     IF COPY (trailer, 1, 3) <> 'end' THEN Abort ('Abnormal end.');
  192.     CLOSE (Infile);
  193.     CLOSE (Outfile)
  194.   END;  {of Terminate}
  195. BEGIN {uudecode}
  196.   Init;
  197.   NextLine(Line);
  198.   WHILE Check_Line DO BEGIN
  199.     DecodeLine;
  200.     NextLine(Line)
  201.   END;
  202.   Terminate
  203. END;
  204.  
  205. procedure hide(question_name:string);
  206. {v1.1 Toad Hall Tweak, 9 May 90
  207.  - Converted reserved, other word case to my preferred style.
  208.  - Converted for Turbo Pascal v5.0 compilation ("Uses", etc.)
  209. }
  210.  
  211. CONST
  212.   Header = 'begin';
  213.   Trailer = 'end';
  214.   DefaultMode = '644';
  215.   DefaultExtension = '.uue';
  216.   OFFSET = 32;
  217.   CHARSPERLINE = 60;
  218.   BYTESPERHUNK = 3;
  219.   SIXBITMASK = $3F;
  220.   
  221. TYPE
  222.   Str80 = STRING[80];
  223.   
  224. VAR
  225.   P : PathStr;
  226.   D : DirStr;
  227.   N : NameStr;
  228.   E : ExtStr;
  229.   Infile: FILE OF Byte;
  230.   Outfile: TEXT;
  231.   Infilename, Outfilename, Mode: Str80;
  232.   lineLength, numbytes, bytesInLine: INTEGER;
  233.   Line: ARRAY [0..59] OF CHAR;
  234.   hunk: ARRAY [0..2] OF Byte;
  235.   chars: ARRAY [0..3] OF Byte;
  236.   size,remaining : longint;  {v1.1 REAL;}
  237.   out_file_OK : Boolean;
  238.   i1 : integer;
  239. {  procedure debug;
  240.     var i: integer;
  241.     procedure writebin(x: byte);
  242.       var i: integer;
  243.       begin
  244.         for i := 1 to 8 do begin
  245.             write ((x and $80) shr 7);
  246.             x := x shl 1
  247.           end;
  248.         write (' ')
  249.       end;
  250.     begin
  251.       for i := 0 to 2 do writebin(hunk[i]);
  252.       writeln;
  253.       for i := 0 to 3 do writebin(chars[i]);
  254.       writeln;
  255.       for i := 0 to 3 do writebin(chars[i] and SIXBITMASK);
  256.       writeln
  257.     end;  }
  258. PROCEDURE Abort (Msg : Str80);
  259.   BEGIN
  260.     WRITELN(Msg);
  261.     {$I-}                 {v1.1}
  262.     CLOSE(Infile);
  263.     CLOSE(Outfile);
  264.     {$I+}                 {v1.1}
  265.     HALT
  266.   END; {of Abort}
  267. PROCEDURE Init;
  268.   PROCEDURE GetFiles;
  269.     VAR
  270.       i : INTEGER;
  271.       TempS : Str80;
  272.       Ch : CHAR;
  273.     BEGIN
  274. (*      IF ParamCount < 1 THEN Abort ('No input file specified.');
  275.       Infilename := ParamStr(1);*)
  276.       InFileName := Question_Name+'.$$$';
  277.       {$I-}
  278.       ASSIGN (Infile, Infilename);
  279.       RESET (Infile);
  280.       {$I+}
  281.       IF IOResult > 0 THEN Abort (CONCAT ('Can''t open file ', Infilename));
  282.  
  283.       size := FileSize(Infile);
  284. (*     IF size < 0 THEN size:=size+65536.0;*)
  285. (* get the number of bytes of data to be encrypted and saved
  286.       remaining := size;*)
  287.       Outfilename := Question_Name+'.UUE';
  288.       Mode := DefaultMode;
  289.       out_file_OK := False;
  290.       repeat
  291.       ASSIGN (Outfile, Outfilename);
  292.       {$I-}
  293.       RESET(Outfile);
  294.       {$I+}
  295.       IF IOResult = 0 THEN BEGIN         {output file exists!}
  296.          FSplit(P,D,N,E);
  297.          i1 := Ord(E[4]);
  298.          E[4] := Chr(i1);
  299.          OutFileName := D + N + E;    {system allows uue, uuf, uug etc.}
  300.       end;
  301.       {$I-}
  302.       CLOSE(Outfile);
  303.       IF IOResult <> 0 THEN ;  {v1.1 we don't care}
  304.       REWRITE(Outfile);
  305.       {$I+}
  306.       IF IOResult > 0 THEN Abort(
  307.         CONCAT('Can''t open ', Outfilename,';Major error'))
  308.       else out_file_OK := True;
  309.       until Out_file_OK;
  310.  
  311.     END; {of GetFiles}
  312.   BEGIN {Init}
  313.     GetFiles;
  314.     bytesInLine := 0;
  315.     lineLength := 0;
  316.     numbytes := 0;
  317.     WRITELN (Outfile, Header, ' ', Mode, ' ', Question_Name+'.ENC');
  318.   END; {init}
  319. {You'll notice from here on we don't do any error-trapping on disk
  320.  read/writes.  We just let DOS do the job.  Any errors are terminal
  321.  anyway, right?
  322. }
  323. PROCEDURE FlushLine;
  324.   VAR i: INTEGER;
  325.   PROCEDURE WriteOut(Ch: CHAR);
  326.     BEGIN
  327.       IF Ch = ' ' THEN WRITE(Outfile, '`')
  328.                   ELSE WRITE(Outfile, Ch)
  329.     END; {of WriteOut}
  330.   BEGIN {FlushLine}
  331.     {write ('.');}
  332.     WriteOut(CHR(bytesInLine + OFFSET));
  333.     FOR i := 0 TO PRED(lineLength) DO
  334.       WriteOut(Line[i]);
  335.     WRITELN (Outfile);
  336.     lineLength := 0;
  337.     bytesInLine := 0
  338.   END; {of FlushLine}
  339. PROCEDURE FlushHunk;
  340.   VAR i: INTEGER;
  341.   BEGIN
  342.     IF lineLength = CHARSPERLINE THEN FlushLine;
  343.     chars[0] := hunk[0] ShR 2;
  344.     chars[1] := (hunk[0] ShL 4) + (hunk[1] ShR 4);
  345.     chars[2] := (hunk[1] ShL 2) + (hunk[2] ShR 6);
  346.     chars[3] := hunk[2] AND SIXBITMASK;
  347.     {debug;}
  348.     FOR i := 0 TO 3 DO BEGIN
  349.       Line[lineLength] := CHR((chars[i] AND SIXBITMASK) + OFFSET);
  350.       {write(line[linelength]:2);}
  351.       Inc(lineLength);
  352.     END;
  353.     {writeln;}
  354.     Inc(bytesInLine,numbytes);
  355.     numbytes := 0
  356.   END; {of FlushHunk}
  357. PROCEDURE Encode1;
  358.   BEGIN
  359.     IF numbytes = BYTESPERHUNK THEN FlushHunk;
  360.     READ (Infile, hunk[numbytes]);
  361.     (*move numbytes of internal data to hunk[numbytes] *)
  362.     Dec(remaining);
  363.     Inc(numbytes);
  364.   END; {of Encode1}
  365. PROCEDURE Terminate;
  366.   BEGIN
  367.     IF numbytes > 0 THEN FlushHunk;
  368.     IF lineLength > 0 THEN BEGIN
  369.       FlushLine;
  370.       FlushLine;
  371.     END
  372.     ELSE FlushLine;
  373.     WRITELN (Outfile, Trailer);
  374.     CLOSE (Outfile);
  375.     CLOSE (Infile);
  376.     Erase(Infile); {get rid of the student response file}
  377.   END; {Terminate}
  378.   BEGIN {uuencode}
  379.     Init;
  380.     WHILE NOT EOF (Infile) DO Encode1;
  381.     Terminate;
  382.     WRITELN;
  383.   END; {hide-really just uuencode again}
  384.  
  385. procedure encode;
  386. {v1.1 Toad Hall Tweak, 9 May 90
  387.  - Converted reserved, other word case to my preferred style.
  388.  - Converted for Turbo Pascal v5.0 compilation ("Uses", etc.)
  389. }
  390.  
  391. CONST
  392.   Header = 'begin';
  393.   Trailer = 'end';
  394.   DefaultMode = '644';
  395.   DefaultExtension = '.uue';
  396.   OFFSET = 32;
  397.   CHARSPERLINE = 60;
  398.   BYTESPERHUNK = 3;
  399.   SIXBITMASK = $3F;
  400. TYPE
  401.   Str80 = STRING[80];
  402. VAR
  403.   Infile: FILE OF Byte;
  404.   Outfile: TEXT;
  405.   Infilename, Outfilename, Mode: Str80;
  406.   lineLength, numbytes, bytesInLine: INTEGER;
  407.   Line: ARRAY [0..59] OF CHAR;
  408.   hunk: ARRAY [0..2] OF Byte;
  409.   chars: ARRAY [0..3] OF Byte;
  410.   size,remaining : longint;  {v1.1 REAL;}
  411.   out_file_OK : Boolean;
  412.   i1 : integer;
  413. {  procedure debug;
  414.     var i: integer;
  415.     procedure writebin(x: byte);
  416.       var i: integer;
  417.       begin
  418.         for i := 1 to 8 do begin
  419.             write ((x and $80) shr 7);
  420.             x := x shl 1
  421.           end;
  422.         write (' ')
  423.       end;
  424.     begin
  425.       for i := 0 to 2 do writebin(hunk[i]);
  426.       writeln;
  427.       for i := 0 to 3 do writebin(chars[i]);
  428.       writeln;
  429.       for i := 0 to 3 do writebin(chars[i] and SIXBITMASK);
  430.       writeln
  431.     end;  }
  432. PROCEDURE Abort (Msg : Str80);
  433.   BEGIN
  434.     WRITELN(Msg);
  435.     {$I-}                 {v1.1}
  436.     CLOSE(Infile);
  437.     CLOSE(Outfile);
  438.     {$I+}                 {v1.1}
  439.     HALT
  440.   END; {of Abort}
  441. PROCEDURE Init;
  442.   PROCEDURE GetFiles;
  443.     VAR
  444.       i : INTEGER;
  445.       TempS : Str80;
  446.       Ch : CHAR;
  447.     BEGIN
  448. (*      IF ParamCount < 1 THEN Abort ('No input file specified.');
  449.       Infilename := ParamStr(1);*)
  450.       InFileName := 'NEWGRADE.BK$';
  451.       {$I-}
  452.       ASSIGN (Infile, Infilename);
  453.       RESET (Infile);
  454.       {$I+}
  455.       IF IOResult > 0 THEN Abort (CONCAT ('Can''t open file ', Infilename));
  456.  
  457.       size := FileSize(Infile);
  458. (*     IF size < 0 THEN size:=size+65536.0;*)
  459. (* get the number of bytes of data to be encrypted and saved
  460.       remaining := size;*)
  461.       Outfilename := 'GRADE.BK$';
  462.       Mode := DefaultMode;
  463.       { Process 2d cmdline arg (if any).
  464.         It could be a new mode (rather than default "644")
  465.         or it could be a forced output name (rather than
  466.         "infile.uue")
  467.       }
  468.  
  469.       out_file_OK := False;
  470.       repeat
  471.       ASSIGN (Outfile, Outfilename);
  472.       {$I-}
  473.       RESET(Outfile);
  474.       {$I+}
  475.       IF IOResult = 0 THEN BEGIN         {output file exists!}
  476.          i1 := Ord(outfilename[11]);
  477.          OutFileName[11] := CHR(i1);     {system allows uue, uuf, uug etc.}
  478.       end;
  479.       {$I-}
  480.       CLOSE(Outfile);
  481.       IF IOResult <> 0 THEN ;  {v1.1 we don't care}
  482.       REWRITE(Outfile);
  483.       {$I+}
  484.       IF IOResult > 0 THEN Abort(
  485.         CONCAT('Can''t open ', Outfilename,';Major error'))
  486.       else out_file_OK := True;
  487.       until Out_file_OK;
  488.  
  489.     END; {of GetFiles}
  490.   BEGIN {Init}
  491.     GetFiles;
  492.     bytesInLine := 0;
  493.     lineLength := 0;
  494.     numbytes := 0;
  495.     WRITELN (Outfile, Header, ' ', Mode, ' ', 'GRADEB.OOK');
  496.   END; {init}
  497. {You'll notice from here on we don't do any error-trapping on disk
  498.  read/writes.  We just let DOS do the job.  Any errors are terminal
  499.  anyway, right?
  500. }
  501. PROCEDURE FlushLine;
  502.   VAR i: INTEGER;
  503.   PROCEDURE WriteOut(Ch: CHAR);
  504.     BEGIN
  505.       IF Ch = ' ' THEN WRITE(Outfile, '`')
  506.                   ELSE WRITE(Outfile, Ch)
  507.     END; {of WriteOut}
  508.   BEGIN {FlushLine}
  509.     {write ('.');}
  510.     WriteOut(CHR(bytesInLine + OFFSET));
  511.     FOR i := 0 TO PRED(lineLength) DO
  512.       WriteOut(Line[i]);
  513.     WRITELN (Outfile);
  514.     lineLength := 0;
  515.     bytesInLine := 0
  516.   END; {of FlushLine}
  517. PROCEDURE FlushHunk;
  518.   VAR i: INTEGER;
  519.   BEGIN
  520.     IF lineLength = CHARSPERLINE THEN FlushLine;
  521.     chars[0] := hunk[0] ShR 2;
  522.     chars[1] := (hunk[0] ShL 4) + (hunk[1] ShR 4);
  523.     chars[2] := (hunk[1] ShL 2) + (hunk[2] ShR 6);
  524.     chars[3] := hunk[2] AND SIXBITMASK;
  525.     {debug;}
  526.     FOR i := 0 TO 3 DO BEGIN
  527.       Line[lineLength] := CHR((chars[i] AND SIXBITMASK) + OFFSET);
  528.       {write(line[linelength]:2);}
  529.       Inc(lineLength);
  530.     END;
  531.     {writeln;}
  532.     Inc(bytesInLine,numbytes);
  533.     numbytes := 0
  534.   END; {of FlushHunk}
  535. PROCEDURE Encode1;
  536.   BEGIN
  537.     IF numbytes = BYTESPERHUNK THEN FlushHunk;
  538.     READ (Infile, hunk[numbytes]);
  539.     (*move numbytes of internal data to hunk[numbytes] *)
  540.     Dec(remaining);
  541.     Inc(numbytes);
  542.   END; {of Encode1}
  543. PROCEDURE Terminate;
  544.   BEGIN
  545.     IF numbytes > 0 THEN FlushHunk;
  546.     IF lineLength > 0 THEN BEGIN
  547.       FlushLine;
  548.       FlushLine;
  549.     END
  550.     ELSE FlushLine;
  551.     WRITELN (Outfile, Trailer);
  552.     CLOSE (Outfile);
  553.     CLOSE (Infile);
  554.   END; {Terminate}
  555.   BEGIN {uuencode}
  556.     Init;
  557.     WHILE NOT EOF (Infile) DO Encode1;
  558.     Terminate;
  559.     WRITELN;
  560.   END; {uuencode}
  561. END.
  562.